perm filename T1X.F4[M11,LCS]2 blob
sn#396921 filedate 1978-11-22 generic text, type T, neo UTF8
00100 C*** 33 PARAMS SEEMS TO BE LIMIT IN THIS VERSION. (30 IN 'SCORE') *****
00200 SUBROUTINE TRANS(JJJ)
00300 DIMENSION IINS(135),FQDR(28,27)
00400 C W(35) FOR PARAMETERS
00500 COMMON /TR/I(80),RX(100),JX(100),LX(12),INST(27,5),MX5(40)
00600 1,INSNUM(27),P(30),NPAR(27),JSEM,IPRNT,IPP
00700 1,SRATE,RNCHN,RMAG,INUM,INS,MM,M,N,JJ,X,Y,IK
00800 1,ENDX,J /KNAM/KNAM,IPLAY,JFLNM,IOPEN /IFIRST/IFIRST,IDT
00900 COMMON /SBFILN/SBFILN /AR/IOP /IGEN/IGEN /JP/JPRNT,JWRT
01000 COMMON LL /P/W(1)
01100 INTEGER FQDR
01200 CXX DOUBLE PRECISION IDBL,JANP,JBLA,IAT,IPERC,JFLNM,IDBG
01300 EQUIVALENCE (LESS,LX(9)),(IX,IXJ,JX),(RX2,RX(3)),
01400 1(P2,P(2)),(RX3,RX(5)),(I3,I(3)),(ISEMI,LX(2))
01500 1,(IBLA,LX(1)),(IAST,LX(3)),(IINS,INST)
01600 1,(IAROW,LX(7))
01700 CXX DATA LX/' ',';', '*','/','-','+'
01800 CXX 1,'←','=', '<', ',', '(', ')'/, IFIRST/-1/,IOPEN/-1/
01900 DATA LX/' ',';', '*','/','-','+'
02000 1,"575004020100,'=','<' ,',' ,'(', ')'/, IOPEN/-1/
02100 1 , IDOT/'.'/, IDEV/1/,JPRNT/1/,JWRT/-1/,JFLNM/'TRNS'/,IAT/'@ '/
02200 1,JBLA/' '/,IDBG/'# '/,JDBG/'#'/
02300 C*** THIS VERSION STARTS OUT WITH DEFAULT OUTPUT TO FILE: TRNS.DAT
02400 DATA RMAG/.0512/,INUM/0/,SRATE/12800./,RNCHN/1./
02500 1,IEXP/'!'/,IPERC/'% '/,JANP/'& '/
02600 1,IANP/'&'/
02700 1,IALT/"765004020100/
02800 CXX 1,IALT/'"'/
02900
03000
03100 GO TO (555,5002) JJJ
03200 555 LLLL=0
03300 401 IF(IFIRST)404, 5,600
03400 404 IGEN=-1
03500 IF(INUM.NE.0)GO TO 30
03600 DO 411 K=1,135
03700 411 IINS(K)=0
03800 C ZERO OUT INSTR. NAME ARRAY.
03900 30 IPLAY=0
04000 ENDX=0
04100 JSEM=0
04200 INS=-1
04300 402 IDEV=1
04400 TYPE 1
04500 1 FORMAT(' INPUT? '$)
04600 100 FORMAT(' >'$)
04700 2 FORMAT(A4)
04800 ACCEPT 2,IDBL
04900 C IDBL WILL HAVE TO BE DOUBLE PREC. ON PDP11 ************
05000 IF(IDBL.NE.JBLA)GO TO 400
05100 IDEV=5
05200 GO TO 5
05300 400 IF(IDBL.EQ.JANP)GO TO 603
05400 C!*** & IS PRNT-NOPRNT FLIPFLOP
05500 IF(IDBL.NE.IDBG)GO TO 410
05600 4448 TYPE 4023
05700 4446 TYPE 4445
05800 ACCEPT 51,KI
05900 IF(KI.EQ.0)GO TO 4022
06000 IF(KI.GT.0)GO TO 4447
06100 C******** THIS STUFF FOR DIAGNOSIS
06200 IF(KI.EQ.-1)TYPE 2325,IGEN
06300 IF(KI.EQ.-2)TYPE 2325,IPRNT
06400 IF(KI.EQ.-3)TYPE 2325,IPLAY
06500 IF(KI.EQ.-4)TYPE 2325,JSEM
06600 IF(KI.EQ.-5)TYPE 2325,J
06700 IF(KI.EQ.-6)TYPE 2325,MM
06800 GO TO 4446
06900 4022 IF(IDEV.EQ.1)GO TO 402
07000 C GO BACK TO 'INPUT' OR '>'
07100 GO TO 502
07200 C THIS WILL TYPE OUT ELEMENTS OF LX ARRAY.
07300 4447 TYPE 2326,LX(KI)
07400 TYPE 2325,LX(KI)
07500 GO TO 4446
07600 4445 FORMAT(' TYPE LX NUMB. '$)
07700 4023 FORMAT(' IGEN, IPRNT, IPLAY, JSEM, J, MM'/)
07800 4444 IF(IDBL.NE.IAT)GO TO 410
07900 C!*** @ IS USED TO SET OUTPUT FILE NAME (DEFAULT=FOR21)
08000 TYPE 399
08100 399 FORMAT(' TYPE OUTPUT NAME -- ',$)
08200 ACCEPT 2,JFLNM
08300 GO TO 402
08400 CCC IF(IDBL.EQ.'%')GO TO 604
08500 C!*** % IS WRT-NOWRT FLIPFLOP
08600 C! % WRITES BINARY FILE.
08700 2324 FORMAT(1X12F/)
08800 2325 FORMAT(1X5I/)
08900 2326 FORMAT(1X80A1)
09000 CX410 CALL OPEN(1,IDBL,0,'RDO')
09100 410 CALL IFILE(1,IDBL)
09200 4 FORMAT(80A1)
09300 C****************
09400 CX TYPE 2325,JSEM
09500 CX TYPE 2325,J
09600 CX TYPE 2325,MM
09700 5 IF(JSEM.AND.J.LT.MM)GO TO 305
09800 IF(JSEM.NE.99)GO TO 502
09900 IFIRST=IFIRST+10
10000 GO TO 555
10100 600 JSEM=0
10200 IFIRST=IFIRST-10
10300 INS=-1
10400 502 IF(IDEV.NE.5)GO TO 601
10500 CX TYPE 2325,IDEV
10600 C*******************************
10700 IF(IGEN.NE.2)IGEN=-1
10800 TYPE 100
10900 CX601 TYPE 2325,INS
11000 C*******************************
11100 601 READ(IDEV,4,END=404)I
11200 IF(IDEV.EQ.5)GO TO 1232
11300 KI=80
11400 1233 IF(I(KI).NE.IBLA)GO TO 1234
11500 KI=KI-1
11600 IF(KI.GT.0)GO TO 1233
11700 1234 IF(JPRNT.LT.0)TYPE 2326,(I(IJI),IJI=1,KI)
11800 GO TO 602
11900 1232 IF(I(1).EQ.IBLA)GO TO 404
12000 C!**** USE BLANK (<CR>) TO RETURN TO 'INPUT?'
12100 IF(I(1).EQ.JDBG)GO TO 4448
12200 C TYPE '#' FOR SOME DEBUGGING
12300 CCC IF(I(1).EQ.'%')GO TO 604
12400 C!*** %=WRITES BINARY FILE FOR21.DAT
12500 IF(I(1).NE.IANP)GO TO 602
12600 C!*** &=TYPE OUT MUS5 NUMBERS
12700 603 JPRNT=-JPRNT
12800 IF(IDEV.EQ.1)GO TO 402
12900 C IDEV=1 = GO BACK TO 'INPUT'
13000 GO TO 502
13100 CCC604 JWRT=-JWRT
13200 C!*** DEFAULT IS NO-WRITE BINARY
13300 CCC GO TO 401
13400 602 IF(I(1).NE.IALT)GO TO 408
13500 CCC IF(I(2).NE.'I')GO TO 605
13600 C!***<ALT>I(NSTRUMENT LIST;) ALT IS DBL QUOTE IN THIS PROG. FOR NOW.
13700 DO 606 K=1,INUM
13800 JK=NPAR(K)-2
13900 606 TYPE 607,(INST(K,L),L=1,5),INSNUM(K),JK
14000 GO TO 5
14100 607 FORMAT(1X,5A1,' NUM=',I2,' PARAMS=',I2)
14200 C!*** PRINTS INST INFO.
14300 CCC605 SBFILN=FILNM
14400 CCCCC CALL PLAY
14500 C!**** GO PLAY SOMETHING
14600 CCC GO TO 5
14700 408 DO 407 K=1,100
14800 407 JX(K)=IBLA
14900 DO 405 K=1,80
15000 IF(I(K).EQ.LESS)GO TO 5
15100 405 IF(I(K).NE.IBLA)GO TO 406
15200 GO TO 5
15300 406 MM=0
15400 DO 4061 J=2,100,2
15500 4061 RX(J)=0
15600 J=-1
15700 IPRNT=0
15800 JI=0
15900 9 M=0
16000 N=JI+1
16100 6 JI=JI+1
16200 K=I(JI)
16300 DO 7 L=1,12
16400 7 IF(K.EQ.LX(L))GO TO 8
16500 M=M+1
16600 GO TO 6
16700 C!**** NO STRING CAN EXCEED 10 CHARS.
16800 8 IF(K.EQ.LESS)GO TO 15
16900 IF(M.EQ.0)GO TO 140
17000 IF(M.GT.10)M=10
17100 MM=MM+1
17200 IF(MM.LE.50)GO TO 88
17300 TYPE 888,(I(JJ),JJ=N,N+9)
17400 STOP
17500 888 FORMAT(' LINE TOO LONG -- ',10A1)
17600 88 JJ=I(N)
17700 IF(JJ.GT.'9')GO TO 16
17800 IF(JJ.NE.IDOT.AND.JJ.LT.'0')GO TO 16
17900 CXX IF(JJ.GT.8249)GO TO 16
18000 CXX IF(JJ.NE.IDOT.AND.JJ.LT.8240)GO TO 16
18100 C**** 8240='0' 8249='9'
18200 C!***** JUMP IF 1ST CHAR. IS A LETTER.
18300 Y=0
18400 DOT=10.
18500 DO 18 JK=N,N+M-1
18600 JA=I(JK)
18700 IF(JA.NE.IDOT)GO TO 17
18800 DOT=.1
18900 GO TO 18
19000 CXX17 X=JA-8240
19100 17 X=NASCI(JA)
19200 C!**** CHANGE ASCII INTO NUMBER
19300 IF(DOT.LT.1)GO TO 19
19400 Y=Y*DOT+X
19500 GO TO 18
19600 19 Y=Y+X*DOT
19700 DOT=DOT/10.
19800 18 CONTINUE
19900 RX(MM*2-1)=Y
20000 RX(MM*2)=-9999.0
20100 GO TO 140
20200 CCC16161 FORMAT(1X,I,3X10A1)
20300
20400 16 JK=MM*2-1
20500 CX JX(JK)=0
20600 CX RX(JK)=0
20700 CX JX(JK+1)=0
20800 CX RX(JK+1)=0
20900 CALL MPACK(M,I(N),JX(JK),N)
21000 C N=CURRENT POINTER TO I ARRAY - USED LATER TO LOCATE INST. NAMES.
21100 IJ=JX(JK)
21200 CCC IF(JPRNT)TYPE 16161,IJ,(I(KHH),KHH=N,N+M-1)
21300 IF(IJ.GE.0)GO TO 244
21400 JX(MM*2)=M
21500 C SAVE THE WD CNT OF POTENTIAL INST. NAME.
21600 GO TO 10
21700 244 IF(IJ.NE.412)GO TO 140
21800 C 412='INSTRUMENT'
21900 INS=0
22000 GO TO 5
22100 144 MX=MX+1
22200 MX5(MX)=IXJ
22300 C!*** PUT IS NEW UNIT GEN. NAME
22400 MX=MX+1
22500 MX5(MX)=RX(3)
22600 GO TO 5
22700 140 IF(IJ.NE.413)GO TO 143
22800 CCC140 IF(IXJ.NE.'UNIT')GO TO 143
22900 INS=1
23000 C!*** 'UNIT GENERATOR' IS RESERVED FOR NEW ONES.
23100 GO TO 5
23200 143 IF(K.EQ.IBLA)GO TO 10
23300 IF(L.EQ.8)K=IAROW
23400 C!::: CHANGE = INTO ←
23500 MM=MM+1
23600 KI=MM*2-1
23700 JX(KI)=K
23800 CC JX(MM*2-1)=K
23900 10 IF(I(JI+1).NE.IBLA)GO TO 11
24000 JI=JI+1
24100 GO TO 10
24200 11 IF(JI.LT.80)GO TO 9
24300 C NOW WE HAVE ALL ITEMS IN IX ARRAY
24400 15 MM=MM*2
24500 IF(IJ.NE.404)GO TO 142
24600 CCC IF(IXJ.NE.KPRNT)GO TO 142
24700 INS=-1
24800 C!***** FOR 'PRINT'
24900 IPRNT=-1
25000 142 J=-1
25100 IF(INS.LT.0)GO TO 305
25200 IF(INS.EQ.2)GO TO 305
25300 26 IF(IJ.NE.12)GO TO 127
25400 CCC26 IF(IXJ.NE.'END')GO TO 127
25500 MM=0
25600 INS=-1
25700 C!***** NOW INITITIALIZATION COMPLETE
25800 GO TO 5
25900 127 IF(INS.EQ.1)GO TO 144
26000 C!*** FOR 'UNIT GEN' ADDED
26100 CXCX ASSUMES INST NAME STARTS IN COL.1 L=N-1
26200 L=0
26300 M=JX(2)
26400 IF(INUM.EQ.0)GO TO 2127
26500 DO 1127 KL=1,INUM
26600 C!** FOR POSSIBLE REDEFINITION OF INST.
26700 CC1127 IF(IXJ.EQ.INST(KL))GO TO 3127
26800 DO 21 LQ=1,M
26900 21 IF(INST(KL,LQ).NE.I(L+LQ))GO TO 1127
27000 C TRY TO MATCH UP LETTERS WITH EXISTING INST. NAMES.
27100 GO TO 3127
27200 C!*** IS INST ALREADY IN LIST?
27300 C JUMP OUT IF MATCH WAS FOUND
27400 1127 CONTINUE
27500 2127 INUM=INUM+1
27600 K=INUM
27700 CC3127 INST(K)=IXJ
27800 DO 20 LQ=1,M
27900 20 INST(K,LQ)=I(L+LQ)
28000 C!**** GET THE NAME OF AN INST.(5 LTRS ONLY)
28100 3127 INSNUM(K)=RX2
28200 C!*** GET ITS NUMBER.
28300 NPAR(K)=RX3+2
28400 C!**** GET NUM OF PARAMS, ADD 3 FOR W ARRAY
28500 DO 2328 KI=1,NPAR(INUM)
28600 2328 FQDR(KI,INUM)=0
28700 K=7
28800 28 LL=-1
28900 IF(JX(K).NE.410)GO TO 31
29000 CCC IF(JX(K).NE.IDUR)GO TO 31
29100 C IF IT'S NOT 'DUR' THEN IT MUST BE 'FREQ'
29200 LL=-LL
29300 C!*** NOW LOOK AT REST OF THE LINE
29400 31 K=K+2
29500 IF(K.GT.MM)GO TO 5
29600 C!**** CHECK FOR END OF LINE
29700 IF(RX(K+1).NE.-9999.0)GO TO 28
29800 JA=RX(K)-2
29900 CC JA=RX(K)+2
30000 IF(JA.LT.1)GO TO 31
30100 CC IF(JA.LT.5)GO TO 31
30200 FQDR(JA,INUM)=LL
30300 C!***** IGNORE P1,P2 OF INPUT
30400 C!**** 1=DUR, -1=FREQ, 0=ORDINARY NUM.
30500 GO TO 31
30600 50 IF(IGEN)308,309,309
30700 309 LL=LL-1
30800 IF(JSEM.LE.0.AND.IGEN.EQ.1)IGEN=-1
30900 C!*** FOUND 'END'
31000 GO TO 59
31100 308 W(1)=1
31200 IF(LL-1.GE.NPAR(IK))GO TO 56
31300 54 IF(LL.LT.3)LL=3
31400 DO 55 K=LL,NPAR(IK)-1
31500 55 W(K)=P(K-2)
31600 C!***** GET INFO ALREADY IN PARAMS
31700 56 DO 57 K=3,LL-1
31800 57 P(K-2)=W(K)
31900 C!**** FILL UP P LIST AGAIN
32000 X=W(3)
32100 C!*** EXCHANGE W(2) AND W(3), ACTION TIME, INST #
32200 W(3)=W(2)
32300 W(2)=X
32400 58 LL=NPAR(IK)
32500 DO 52 K=5,LL-1
32600 KI=FQDR(K-4,IK)
32700 CC X=FQDR(K-4,IK)
32800 IF(KI)53,52,2352
32900 CC IF(X.EQ.0)GO TO 52
33000 CC IF(X)GO TO 53
33100 2352 W(K)=RMAG/W(K)
33200 GO TO 52
33300 53 W(K)=RMAG*W(K)
33400 52 CONTINUE
33500 IF(ENDX.LT.W(2)+P2)ENDX=W(2)+P2
33600 W(LL)=RMAG/W(4)
33700 C!********* PUT MAG/P2 AT END
33800 59 IF(JPRNT.GE.0)GO TO 591
33900 CC TYPE 590,KNAM
34000 KNAM=IBLA
34100 TYPE 51,LL,(W(K),K=1,LL)
34200 CXX WRITE(22,51)LL,(W(K),K=1,LL)
34300 C ABOVE WRITES ONTO FILE 'D.DAT' *** TEMPORARY FOR DEBUGGING.
34400 591 IF(JWRT.GE.0)GO TO 500
34500 CZZ IF(IOPEN.LT.0)CALL OFILE(21,JFLNM)
34600 CXX IF(IOPEN.LT.0)CALL OPEN(21,JFLNM,0,'NEW',,,'UNF')
34700 C OPENS FILE, IF NOT ALREADY OPEN.
34800 CZZ WRITE(21)LL,(W(K),K=1,LL)
34900 IDT=2
35000 RETURN
35100
35200 5002 IOPEN=0
35300 500 IFIRST=0
35400 IF(IGEN.EQ.0)IGEN=-1
35500 IF(W(1).NE.6)GO TO 555
35600 RETURN
35700 C W(1)=6 = 'FINISH;' [W ARRAY IS EQUIV. TO P ARRAY IN MUSIC5]
35800 590 FORMAT(I6)
35900 CCC590 FORMAT(1XA5,1X$)
36000
36100 306 IF(JPRNT.LT.0)TYPE 1307,(W(K),K=1,LL-1)
36200 IF(JPRNT.GT.0)TYPE 307,(W(K),K=1,LL-1)
36300 IPRNT=0
36400 C!** RESET NO-PRNT FLAG
36500 JSEM=0
36600 C!** RESET SEMICOLON FLAG
36700 INS=-1
36800 IF(J.GE.MM-1)GO TO 5
36900 C!** GO READ ANOTHER LINE
37000 305 CALL MSCAN(LL,W)
37100 303 IF(IPRNT.LT.0)GO TO 306
37200 IF(J.LT.MM)JSEM=-1
37300 C!**** STILL MORE CHARS TO COME.
37400 IF(ENDX.GE.0)GO TO 302
37500 ENDX=0
37600 GO TO 500
37700 302 IF(JSEM)50,5,5
37800 51 FORMAT(I3,35F10.3)
37900 307 FORMAT('+',F8.2,$)
38000 1307 FORMAT(F10.3)
38100 END
38200
38300 FUNCTION NASCI(N)
38400 DATA IEX/536870912/,IZERO/'0'/
38500 C THIS BIG NUMBER MUST BE CHANGED ON PDP11***************
38600 NASCI=(N-IZERO)/IEX
38700 C CONVERTS SINGLE ASCII CHARACTER TO INTEGER.
38800 END